home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / dskut / xlat11.zip / XFERXLAT.PAS < prev    next >
Pascal/Delphi Source File  |  1990-08-12  |  17KB  |  439 lines
  1. Program xferxlat;
  2. { Transfer a XLAT translation table between COM and table files.             }
  3. { FreeWare by TapirSoft Gisbert W.Selke, Aug 1990                            }
  4.  
  5. {$UNDEF  DEBUG }        { DEFINE while debugging }
  6.  
  7. {$A+,B-,D+,E+,F-,I+,L+,N-,O-,V- }
  8. {$M 16384,0,16384 }
  9. {$IFDEF DEBUG }
  10.   {$R+,S+ }
  11. {$ELSE }
  12.   {$R-,S- }
  13. {$ENDIF }
  14.  
  15.   Const progname  = 'XferXlat';
  16.         version   = '1.1';
  17.         copyright = 'FreeWare by TapirSoft Gisbert W.Selke, Aug 1990';
  18.         idstring10= 'XLAT10';
  19.         idstring11= 'XLAT11';
  20.         idlength  = Length(idstring10);
  21.         hexnibble : string[16] = '0123456789ABCDEF';
  22.         digits    : string[10] = '0123456789';
  23.  
  24.   Const fbufsize = 4096;
  25.         width    = 18;
  26.  
  27.   Type tabletype = Array [byte] Of byte;
  28.        fbuftype  = Array [1..fbufsize] Of byte;
  29.  
  30.   Var fnamep, fnamet, fnameo : string;
  31.       xlat  : File;
  32.       tabf  : text;
  33.       fbuf  : fbuftype;
  34.       fsize : word;
  35.       transtype : byte;
  36.       doinvert : boolean;
  37.       descript, intername : string;
  38.       tstart, tabstart, interstart : word;
  39.       desclen  : byte;
  40.       xlatid   : byte;
  41.       table    : tabletype;
  42.       exitsave : Pointer;
  43.  
  44.   Function LoCase(ch : char) : char;
  45.   { make characters lower case; national special characters, too!            }
  46.     Inline($58/$3C/$41/$72/$39/$3C/$5A/$76/$33/$3C/$8E/$75/$02/$B0/$84
  47.     /$3C/$99/$75/$02/$B0/$94/$3C/$9A/$75/$02/$B0/$81
  48.     /$3C/$80/$75/$02/$B0/$87/$3C/$8F/$75/$02/$B0/$86
  49.     /$3C/$90/$75/$02/$B0/$82/$3C/$92/$75/$02/$B0/$91
  50.     /$3C/$A5/$75/$02/$B0/$A4/$EB/03/90/$04/$20);
  51.  
  52.   Function hexbyte(b : byte) : string;
  53.   { convert a byte to a string                                               }
  54.   Begin                                                            { hexbyte }
  55.     hexbyte := hexnibble[Succ(b ShR 4)] + hexnibble[Succ(b And $0F)];
  56.   End;                                                             { hexbtye }
  57.  
  58.   Procedure abort(msg : string; errcode : byte);
  59.   { show message and die                                                     }
  60.   Begin                                                              { abort }
  61.     writeln(msg);
  62.     Halt(errcode);
  63.   End;                                                               { abort }
  64.  
  65.   Procedure invert;
  66.   { invert a translation table                                               }
  67.     Var temp : tabletype;
  68.         i : byte;
  69.   Begin                                                             { invert }
  70.     For i :=   0     To   255 Do temp[i] := 0;
  71.     For i := 255 DownTo     0 Do temp[table[i]] := i;
  72.     table := temp;
  73.   End;                                                              { invert }
  74.  
  75.   Procedure loadcom(fname : string; loadcomplete : boolean);
  76.   { load a COM file. if not loadcomplete, then load table data only          }
  77.  
  78.     Const proginfoptr = 4;
  79.  
  80.     Var i, xfsize, xinterstart, xtstart, xtabstart : word;
  81.         xdesclen : byte;
  82.         temp : string;
  83.         fbuf1 : fbuftype;
  84.  
  85.   Begin                                                            { loadcom }
  86.     i := FileMode;
  87.     FileMode := 0;
  88.     Assign(xlat,fname);
  89.     {$I- }
  90.     Reset(xlat,1);
  91.     FileMode := i;
  92.     If IOResult <> 0 Then abort('File ' + fname + ' not found',2);
  93.     BlockRead(xlat,fbuf1,fbufsize,xfsize);
  94.     Close(xlat);
  95.     {$I+ }
  96.     If IOResult <> 0 Then abort('Error reading file ' + fname,3);
  97.     i := fbuf1[proginfoptr] + 1;
  98.     temp[0] := Chr(idlength);
  99.     Move(fbuf1[i],temp[1],idlength);
  100.     xlatid := 0;
  101.     If temp = idstring10 Then xlatid := 10;
  102.     If temp = idstring11 Then xlatid := 11;
  103.     If xlatid = 0 Then abort('Unknown programme version ' + temp + ' in ' +
  104.                              fname,4);
  105.     Move(fbuf1[i+8],xinterstart,2);
  106.     If xinterstart >= xfsize Then abort('File ' + fname +
  107.                                         ' has invalid format',5);
  108.     Inc(xinterstart);
  109.     xtstart := Succ(fbuf1[i+6]);
  110.     xdesclen := fbuf1[i+7];
  111.     Move(fbuf1[i+10],xtabstart,2);
  112.     Inc(xtabstart);
  113.     Move(fbuf1[xtstart],descript[1],xdesclen);
  114.     Move(fbuf1[xtabstart],table,256);
  115.     Move(fbuf1[xinterstart],intername[1],8);
  116.     intername[0] := #8;
  117.     If loadcomplete Then
  118.     Begin
  119.       fbuf        := fbuf1;
  120.       fsize       := xfsize;
  121.       interstart  := xinterstart;
  122.       tstart      := xtstart;
  123.       tabstart    := xtabstart;
  124.       desclen     := xdesclen;
  125.       descript[0] := Chr(desclen);
  126.     End
  127.     Else
  128.     Begin
  129.       For i := Succ(xdesclen) To desclen Do descript[i] := ' ';
  130.     End;
  131.   End;                                                             { loadcom }
  132.  
  133.   Procedure savecom(fname : string);
  134.   { save a translation table as a COM file                                   }
  135.     Var iwrite : word;
  136.   Begin                                                            { savecom }
  137.     intername := fname;
  138.     While (intername <> '') And (Pos(':',intername) > 0) Do
  139.                                   Delete(intername,1,Pos(':',intername));
  140.     While (intername <> '') And (Pos('\',intername) > 0) Do
  141.                                   Delete(intername,1,Pos('\',intername));
  142.     While (intername <> '') And (Pos('.',intername) > 0) Do
  143.                                   Delete(intername,Pos('.',intername),255);
  144.     While Length(intername) < 8 Do intername := intername + ' ';
  145.     {$I- }
  146.     Assign(xlat,fname);
  147.     Rewrite(xlat,1);
  148.     If IOResult <> 0 Then abort('Cannot open ' + fname + ' for output',10);
  149.     Move(descript[1],fbuf[tstart],desclen);
  150.     Move(table,fbuf[tabstart],256);
  151.     Move(intername[1],fbuf[interstart],8);
  152.     BlockWrite(xlat,fbuf,fsize,iwrite);
  153.     If iwrite <> fsize Then abort('Error writing file ' + fname,11);
  154.     Close(xlat);
  155.     {$I+ }
  156.   End;                                                             { savecom }
  157.  
  158.   Procedure loadtable(fname : string);
  159.   { load a translation table from an ASCII table file                        }
  160.  
  161.     Var i : byte;
  162.         tab1 : tabletype;
  163.         descript1, lin, cmd, froms, tos, tname : string;
  164.         fromval, toval : byte;
  165.         ok : boolean;
  166.  
  167.     Function gettok(s : string; Var ptr : byte) : string;
  168.     { returns next token from s, or ''                                       }
  169.       Var beg : byte;
  170.     Begin                                                           { gettok }
  171.       While (ptr <= Length(s)) And ((s[ptr] = ' ') Or (s[ptr] = #9)) Do
  172.                                                                      Inc(ptr);
  173.       beg := ptr;
  174.       While (ptr <= Length(s)) And (s[ptr] <> ' ') And (s[ptr] <> #9) Do
  175.       Begin
  176.         s[ptr] := UpCase(s[ptr]);
  177.         Inc(ptr);
  178.       End;
  179.       gettok := Copy(s,beg,ptr-beg);
  180.     End;                                                            { gettok }
  181.  
  182.     Function decoval(s : string; Var ok : boolean) : byte;
  183.     { decodes a decimal or hexadecimal (prefixed by 'x') value               }
  184.       Var i1, i2, num : byte;
  185.     Begin                                                          { decoval }
  186.       num := 0;
  187.       ok := False;
  188.       If s <> '' Then
  189.       Begin
  190.         If (s[1] = 'X') And (Length(s) >= 1) And (Length(s) <= 3) Then
  191.         Begin
  192.           If Length(s) = 2 Then
  193.           Begin
  194.             s[1] := '0';
  195.             i2 := 1;
  196.           End
  197.             Else i2 := 2;
  198.           i1 := Pos(s[i2],hexnibble);
  199.           i2 := Pos(s[Succ(i2)],hexnibble);
  200.           ok := (i1 > 0) And (i2 > 0);
  201.           If ok Then num := Pred(i1) ShL 4 + Pred(i2);
  202.         End
  203.         Else
  204.         Begin
  205.           For i2 := 1 To Length(s) Do
  206.           Begin
  207.             i1 := Pos(s[i2],digits);
  208.             ok := ok And (i1 > 0);
  209.             If ok Then
  210.             Begin
  211.               If 10*word(num)+ i1 <= 256 Then num := 10*num + Pred(i1);
  212.             End;
  213.           End;
  214.         End;
  215.       End;
  216.       decoval := num;
  217.     End;                                                           { decoval }
  218.  
  219.   Begin                                                          { loadtable }
  220.     i := FileMode;
  221.     FileMode := 0;
  222.     Assign(tabf,fnam